home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PBLIB1 / UNITS / MISCPTIM.INC < prev    next >
Text File  |  1994-02-17  |  7KB  |  248 lines
  1.  
  2. {SECTION DateToJulian }
  3. Function DateToJulian(Date : DateRec) : REAL;
  4.             { Note: This routine adapted from "Turbo Pascal Program Library", by
  5.                   Tom Rugg and Phil Feldman (Que Books, 1986).- via TUG }
  6. var TMonth : REAL;
  7.      begin
  8.      WITH Date DO
  9.           begin
  10.           TMonth    := int((Month - 14.0) / 12.0);
  11.           DateToJulian := Day - 32075.0
  12.                 +  int(1461.0 * (Year + 4800.0 + TMonth) / 4.0)
  13.                 +  int(367.0  * (Month - 2.0 - TMonth * 12.0) / 12.0)
  14.                 -  int(3.0    * int((Year + 4900.0 + TMonth) / 100.0) / 4.0)
  15.           end
  16.      end;
  17.  
  18.  
  19.  
  20. {SECTION  JulianToDate }
  21. Procedure JulianToDate(Julian : REAL; var Date : DateRec);
  22.            { Note: This routine adapted from "Turbo Pascal Program Library", by
  23.                 Tom Rugg and Phil Feldman (Que Books, 1986).- via TUG }
  24.  
  25. var Temp1 : REAL;
  26.     Temp2 : REAL;
  27.  
  28.      begin
  29.      WITH Date DO
  30.           begin
  31.           Temp1 := Julian + 68569.0;
  32.           Temp2 := int(4.0 * Temp1 / 146097.0);
  33.           Temp1 := Temp1 - int((146097.0 * Temp2 + 3.0) / 4.0);
  34.           Year  := trunc(4000.0 * (Temp1 + 1.0) / 1461001.0);
  35.           Temp1 := Temp1 - int(1461.0 * Year / 4.0) + 31.0;
  36.           Month := trunc(80.0 * Temp1 / 2447.0);
  37.           Day   := trunc(Temp1 - int(2447.0 * Month / 80.0));
  38.           Temp1 := int(Month / 11.0);
  39.           Month := trunc(Month + 2.0 - 12.0 * Temp1);
  40.           Year  := trunc(100.0 * (Temp2 - 49.0) + Year + Temp1)
  41.          end
  42.      end;
  43.  
  44.  
  45.  
  46.  
  47.  
  48. {SECTION  DaysBetweenPTimes }
  49. Function  DaysBetweenPTimes(PT1, PT2 : PTime) : longint;
  50.      begin
  51.      DaysBetweenPTimes :=  trunc(PTimeToJulian(PT2) - PTimeToJulian(PT1));
  52.      end;
  53.  
  54.  
  55. {SECTION  DaysBetweenDBaseDates }
  56. Function DaysBetweenDBaseDates(dt1,dt2 : string) : integer;
  57. var d : integer;
  58.     pt1,pt2 : PTime;
  59.      begin
  60.      d := 0;
  61.      pt1 := DBaseToPTime(dt1);
  62.      pt2 := DBaseToPTime(dt2);
  63.      d := DaysBetweenPTimes(pt1,pt2);
  64.      DaysBetweenDBaseDates := d;
  65.      end;
  66.  
  67.  
  68. {SECTION  DaysInMonth }
  69. Function  DaysInMonth(month, year : integer) : byte;
  70. var d : byte;
  71.      begin
  72.      case month of
  73.         1,3,5,7,8,10,12 : d := 31;
  74.         4,6,9,11        : d := 30;
  75.         2               : begin
  76.                           if (year mod 4) = 0 then d := 29
  77.                           else d := 28;
  78.                           end;
  79.         else              d := 31;
  80.         end;
  81.      DaysInMonth := d;
  82.      end;
  83.  
  84.  
  85. {SECTION  DBaseToPTime }
  86. Function  DBaseToPTime(s : string) : PTIME;       { 'yyyymmdd' -> longint }
  87. var PT : PTime;
  88.     dt : datetime;
  89.     dd,mm,yy : integer;
  90.      begin
  91.      dt.year  := StrInt(copy(s,1,4));
  92.      dt.month := StrInt(copy(s,5,2));
  93.      dt.day   := StrInt(copy(s,7,2));
  94.      PackTime(dt,PT);
  95.      DBaseToPTime := PT;
  96.      end;
  97.  
  98.  
  99. {SECTION  FmtPDateStr }
  100. Function  FmtPDateStr(PT : PTime) : string;
  101. var d : DateTime;  { DOS }
  102. var temp : string[8];
  103.      begin
  104.      UnPackTime(PT,d);
  105.      temp :=  FmtYMD(d.year,d.month,d.day);
  106.      FmtPDateStr := temp;
  107.      end;
  108.  
  109.  
  110. {SECTION  FmtPtimeStr }
  111. Function  FmtPTimeStr(PT : PTime) : string;
  112. var d : DateTime;  { DOS }
  113. var temp : string[14];
  114.      begin
  115.      UnPackTime(PT,d);
  116.      temp :=  FmtYMD(d.year,d.month,d.day)+' '+FmtHMS(d.hour,d.min,d.sec);
  117.      FmtPTimeStr := temp;
  118.      end;
  119.  
  120.  
  121. {SECTION  GetCurrPTime }
  122. Function  GetCurrPTime(var pt : PTime) : word;   {function returns day of week}
  123. var dt : datetime;
  124.     doy : word;
  125.     sec100 : word;
  126.      begin
  127.      GetDate(dt.year,dt.month,dt.day,doy);
  128.      GetTime(dt.hour,dt.min,dt.sec,sec100);
  129.      PackTime(dt,pt);
  130.      GetCurrPTime := doy;
  131.      end;
  132.  
  133.  
  134.  
  135. {SECTION  JulianToPTime }
  136. Function  JulianToPTime(J : Julian) : PTime;
  137. var PT : PTime;
  138.     d  : daterec;
  139.     dt : datetime;
  140.      begin
  141.      JulianToDate(J,d);
  142.      fillchar(dt,sizeof(dt),0);
  143.      dt.year := d.year;
  144.      dt.month := d.month;
  145.      dt.day := d.day;
  146.      PackTime(dt,PT);
  147.      JulianToPTime := PT;
  148.      end;
  149.  
  150.  
  151. {SECTION  MonthStr }
  152. Function  MonthStr(mm : integer) : string;
  153.      begin
  154.      monthstr := '???';
  155.      case mm of
  156.           1  : monthstr := 'Jan';
  157.           2  : monthstr := 'Feb';
  158.           3  : monthstr := 'Mar';
  159.           4  : monthstr := 'Apr';
  160.           5  : monthstr := 'May';
  161.           6  : monthstr := 'Jun';
  162.           7  : monthstr := 'Jul';
  163.           8  : monthstr := 'Aug';
  164.           9  : monthstr := 'Sep';
  165.           0  : monthstr := 'Oct';
  166.           11 : monthstr := 'Nov';
  167.           12 : monthstr := 'Dec';
  168.           end;
  169.      end;
  170.  
  171.  
  172. {SECTION  PTDayOfTheWeek }
  173. Function  PTDayOfTheWeek( pt : PTime ) : word;
  174. var doy, doy0    : word;
  175.     l            : longint;
  176.     pt0          : PTime;
  177.      begin  { Totally crude algorithm,  works in 1980s and 1990s,
  178.               unchecked further }
  179.      pt0  := 2162688;  { 1/1/80 }
  180.      doy0 := 2;        { Tuesday }
  181.      l := DaysBetweenPTimes(pt0,pt);
  182.      if l > 0 then doy := ((abs(l) mod 7) + doy0) mod 7
  183.      else doy := ((doy0+7 - abs(l mod 7))) mod 7;
  184.      PTDayOfTheWeek := doy;
  185.      end;
  186.  
  187.  
  188. {SECTION  PTimePlusDays }
  189. Function  PTimePlusDays(PT : PTime; days : integer) : PTime;
  190.      begin
  191.      PTimePlusDays :=  JulianToPTime(PTimeToJulian(PT)+days)
  192.      end;
  193.  
  194.  
  195. {SECTION  PTimeToDBase }
  196. Function  PTimeToDBase(pt : PTime) : string;
  197. var dt  : datetime;
  198.     i   : integer;
  199.     s   : string[8];
  200.      begin
  201.      UnPackTime(pt,dt);
  202.      s := integerstr(dt.year,4) + integerstr(dt.month,2) + integerstr(dt.day,2);
  203.      patchstr(s,' ','0');
  204.      PTimeToDBase := s;
  205.      end;
  206.  
  207.  
  208. {SECTION  PTimeToDMY }
  209. Procedure PTimeToDMY(PT : PTime; var dd,mm,yy : integer);
  210. var dt : DateTime;  { DOS }
  211.      begin
  212.      UnPackTime(PT,dt);
  213.      yy := dt.year;
  214.      mm := dt.month;
  215.      dd := dt.day;
  216.      end;
  217.  
  218.  
  219. {SECTION  PTimeToJulian }
  220. Function  PTimeToJulian(PT : PTime) : real;
  221. var dt : DateTime;  { DOS }
  222.     d : DateRec;   { DateStuf }
  223.      begin
  224.      UnPackTime(PT,dt);
  225.      d.year := dt.year;
  226.      d.month := dt.month;
  227.      d.day  := dt.day;
  228.      PTimetoJulian := DatetoJulian(d);
  229.      end;
  230.  
  231.  
  232. {SECTION StringToPTime  }
  233. Function StringToPTime(s : string) : PTIME;
  234. var PT : PTime;
  235.     dt : datetime;
  236.     dd,mm,yy : integer;
  237.      begin
  238.      fillchar(dt,sizeof(dt),0);
  239.      StrCal(s,dd,mm,yy);
  240.      dt.year := yy;
  241.      dt.month := mm;
  242.      dt.day := dd;
  243.      if dt.year < 1900 then dt.year := dt.year + 1900;
  244.      PackTime(dt,PT);
  245.      StringToPTime := PT;
  246.      end;
  247.  
  248.